home *** CD-ROM | disk | FTP | other *** search
/ FishMarket 1.0 / FishMarket v1.0.iso / fishies / 001-025 / disk_003 / xlisp / xlcont.c < prev    next >
C/C++ Source or Header  |  1992-05-06  |  17KB  |  799 lines
  1. /* xlcont - xlisp control built-in functions */
  2.  
  3. #include "xlisp.h"
  4.  
  5. /* external variables */
  6. extern NODE *xlstack,*xlenv,*xlnewenv,*xlvalue;
  7. extern NODE *s_unbound;
  8. extern NODE *s_evalhook,*s_applyhook;
  9. extern NODE *true;
  10.  
  11. /* external routines */
  12. extern NODE *xlxeval();
  13.  
  14. /* forward declarations */
  15. FORWARD NODE *let();
  16. FORWARD NODE *prog();
  17. FORWARD NODE *progx();
  18. FORWARD NODE *doloop();
  19.  
  20. /* xcond - built-in function 'cond' */
  21. NODE *xcond(args)
  22.   NODE *args;
  23. {
  24.     NODE *oldstk,arg,list,*val;
  25.  
  26.     /* create a new stack frame */
  27.     oldstk = xlsave(&arg,&list,NULL);
  28.  
  29.     /* initialize */
  30.     arg.n_ptr = args;
  31.  
  32.     /* initialize the return value */
  33.     val = NIL;
  34.  
  35.     /* find a predicate that is true */
  36.     while (arg.n_ptr) {
  37.  
  38.     /* get the next conditional */
  39.     list.n_ptr = xlmatch(LIST,&arg.n_ptr);
  40.  
  41.     /* evaluate the predicate part */
  42.     if (xlevarg(&list.n_ptr)) {
  43.  
  44.         /* evaluate each expression */
  45.         while (list.n_ptr)
  46.         val = xlevarg(&list.n_ptr);
  47.  
  48.         /* exit the loop */
  49.         break;
  50.     }
  51.     }
  52.  
  53.     /* restore the previous stack frame */
  54.     xlstack = oldstk;
  55.  
  56.     /* return the value */
  57.     return (val);
  58. }
  59.  
  60. /* xand - built-in function 'and' */
  61. NODE *xand(args)
  62.   NODE *args;
  63. {
  64.     NODE *oldstk,arg,*val;
  65.  
  66.     /* create a new stack frame */
  67.     oldstk = xlsave(&arg,NULL);
  68.  
  69.     /* initialize */
  70.     arg.n_ptr = args;
  71.     val = true;
  72.  
  73.     /* evaluate each argument */
  74.     while (arg.n_ptr)
  75.  
  76.     /* get the next argument */
  77.     if ((val = xlevarg(&arg.n_ptr)) == NIL)
  78.         break;
  79.  
  80.     /* restore the previous stack frame */
  81.     xlstack = oldstk;
  82.  
  83.     /* return the result value */
  84.     return (val);
  85. }
  86.  
  87. /* xor - built-in function 'or' */
  88. NODE *xor(args)
  89.   NODE *args;
  90. {
  91.     NODE *oldstk,arg,*val;
  92.  
  93.     /* create a new stack frame */
  94.     oldstk = xlsave(&arg,NULL);
  95.  
  96.     /* initialize */
  97.     arg.n_ptr = args;
  98.     val = NIL;
  99.  
  100.     /* evaluate each argument */
  101.     while (arg.n_ptr)
  102.     if ((val = xlevarg(&arg.n_ptr)))
  103.         break;
  104.  
  105.     /* restore the previous stack frame */
  106.     xlstack = oldstk;
  107.  
  108.     /* return the result value */
  109.     return (val);
  110. }
  111.  
  112. /* xif - built-in function 'if' */
  113. NODE *xif(args)
  114.   NODE *args;
  115. {
  116.     NODE *oldstk,testexpr,thenexpr,elseexpr,*val;
  117.  
  118.     /* create a new stack frame */
  119.     oldstk = xlsave(&testexpr,&thenexpr,&elseexpr,NULL);
  120.  
  121.     /* get the test expression, then clause and else clause */
  122.     testexpr.n_ptr = xlarg(&args);
  123.     thenexpr.n_ptr = xlarg(&args);
  124.     elseexpr.n_ptr = (args ? xlarg(&args) : NIL);
  125.     xllastarg(args);
  126.  
  127.     /* evaluate the appropriate clause */
  128.     val = xleval(xleval(testexpr.n_ptr) ? thenexpr.n_ptr : elseexpr.n_ptr);
  129.  
  130.     /* restore the previous stack frame */
  131.     xlstack = oldstk;
  132.  
  133.     /* return the last value */
  134.     return (val);
  135. }
  136.  
  137. /* xlet - built-in function 'let' */
  138. NODE *xlet(args)
  139.   NODE *args;
  140. {
  141.     return (let(args,TRUE));
  142. }
  143.  
  144. /* xletstar - built-in function 'let*' */
  145. NODE *xletstar(args)
  146.   NODE *args;
  147. {
  148.     return (let(args,FALSE));
  149. }
  150.  
  151. /* let - common let routine */
  152. LOCAL NODE *let(args,pflag)
  153.   NODE *args; int pflag;
  154. {
  155.     NODE *oldstk,*oldenv,*oldnewenv,arg,*val;
  156.  
  157.     /* create a new stack frame */
  158.     oldstk = xlsave(&arg,NULL);
  159.  
  160.     /* initialize */
  161.     arg.n_ptr = args;
  162.  
  163.     /* get the list of bindings and bind the symbols */
  164.     oldnewenv = xlnewenv; oldenv = xlnewenv = xlenv;
  165.     dobindings(xlmatch(LIST,&arg.n_ptr),pflag);
  166.  
  167.     /* execute the code */
  168.     for (val = NIL; arg.n_ptr; )
  169.     val = xlevarg(&arg.n_ptr);
  170.  
  171.     /* unbind the arguments */
  172.     xlunbind(oldenv); xlnewenv = oldnewenv;
  173.  
  174.     /* restore the previous stack frame */
  175.     xlstack = oldstk;
  176.  
  177.     /* return the result */
  178.     return (val);
  179. }
  180.  
  181. /* xprog - built-in function 'prog' */
  182. NODE *xprog(args)
  183.   NODE *args;
  184. {
  185.     return (prog(args,TRUE));
  186. }
  187.  
  188. /* xprogstar - built-in function 'prog*' */
  189. NODE *xprogstar(args)
  190.   NODE *args;
  191. {
  192.     return (prog(args,FALSE));
  193. }
  194.  
  195. /* prog - common prog routine */
  196. LOCAL NODE *prog(args,pflag)
  197.   NODE *args; int pflag;
  198. {
  199.     NODE *oldstk,*oldenv,*oldnewenv,arg,*val;
  200.  
  201.     /* create a new stack frame */
  202.     oldstk = xlsave(&arg,NULL);
  203.  
  204.     /* initialize */
  205.     arg.n_ptr = args;
  206.  
  207.     /* get the list of bindings and bind the symbols */
  208.     oldnewenv = xlnewenv; oldenv = xlnewenv = xlenv;
  209.     dobindings(xlmatch(LIST,&arg.n_ptr),pflag);
  210.  
  211.     /* execute the code */
  212.     tagblock(arg.n_ptr,&val);
  213.  
  214.     /* unbind the arguments */
  215.     xlunbind(oldenv); xlnewenv = oldnewenv;
  216.  
  217.     /* restore the previous stack frame */
  218.     xlstack = oldstk;
  219.  
  220.     /* return the result */
  221.     return (val);
  222. }
  223.  
  224. /* xgo - built-in function 'go' */
  225. NODE *xgo(args)
  226.   NODE *args;
  227. {
  228.     NODE *label;
  229.  
  230.     /* get the target label */
  231.     label = xlarg(&args);
  232.     xllastarg(args);
  233.  
  234.     /* transfer to the label */
  235.     xlgo(label);
  236. }
  237.  
  238. /* xreturn - built-in function 'return' */
  239. NODE *xreturn(args)
  240.   NODE *args;
  241. {
  242.     NODE *val;
  243.  
  244.     /* get the return value */
  245.     val = (args ? xlarg(&args) : NIL);
  246.     xllastarg(args);
  247.  
  248.     /* return from the inner most block */
  249.     xlreturn(val);
  250. }
  251.  
  252. /* xprog1 - built-in function 'prog1' */
  253. NODE *xprog1(args)
  254.   NODE *args;
  255. {
  256.     return (progx(args,1));
  257. }
  258.  
  259. /* xprog2 - built-in function 'prog2' */
  260. NODE *xprog2(args)
  261.   NODE *args;
  262. {
  263.     return (progx(args,2));
  264. }
  265.  
  266. /* progx - common progx code */
  267. LOCAL NODE *progx(args,n)
  268.   NODE *args; int n;
  269. {
  270.     NODE *oldstk,arg,val;
  271.  
  272.     /* create a new stack frame */
  273.     oldstk = xlsave(&arg,&val,NULL);
  274.  
  275.     /* initialize */
  276.     arg.n_ptr = args;
  277.  
  278.     /* evaluate the first n expressions */
  279.     while (n--)
  280.     val.n_ptr = xlevarg(&arg.n_ptr);
  281.  
  282.     /* evaluate each remaining argument */
  283.     while (arg.n_ptr)
  284.     xlevarg(&arg.n_ptr);
  285.  
  286.     /* restore the previous stack frame */
  287.     xlstack = oldstk;
  288.  
  289.     /* return the last test expression value */
  290.     return (val.n_ptr);
  291. }
  292.  
  293. /* xprogn - built-in function 'progn' */
  294. NODE *xprogn(args)
  295.   NODE *args;
  296. {
  297.     NODE *oldstk,arg,*val;
  298.  
  299.     /* create a new stack frame */
  300.     oldstk = xlsave(&arg,NULL);
  301.  
  302.     /* initialize */
  303.     arg.n_ptr = args;
  304.  
  305.     /* evaluate each remaining argument */
  306.     for (val = NIL; arg.n_ptr; )
  307.     val = xlevarg(&arg.n_ptr);
  308.  
  309.     /* restore the previous stack frame */
  310.     xlstack = oldstk;
  311.  
  312.     /* return the last test expression value */
  313.     return (val);
  314. }
  315.  
  316. /* xdo - built-in function 'do' */
  317. NODE *xdo(args)
  318.   NODE *args;
  319. {
  320.     return (doloop(args,TRUE));
  321. }
  322.  
  323. /* xdostar - built-in function 'do*' */
  324. NODE *xdostar(args)
  325.   NODE *args;
  326. {
  327.     return (doloop(args,FALSE));
  328. }
  329.  
  330. /* doloop - common do routine */
  331. LOCAL NODE *doloop(args,pflag)
  332.   NODE *args; int pflag;
  333. {
  334.     NODE *oldstk,*oldenv,*oldnewenv,arg,blist,clist,test,*rval;
  335.     int rbreak;
  336.  
  337.     /* create a new stack frame */
  338.     oldstk = xlsave(&arg,&blist,&clist,&test,NULL);
  339.  
  340.     /* initialize */
  341.     arg.n_ptr = args;
  342.  
  343.     /* get the list of bindings and bind the symbols */
  344.     blist.n_ptr = xlmatch(LIST,&arg.n_ptr);
  345.     oldnewenv = xlnewenv; oldenv = xlnewenv = xlenv;
  346.     dobindings(blist.n_ptr,pflag);
  347.  
  348.     /* get the exit test and result forms */
  349.     clist.n_ptr = xlmatch(LIST,&arg.n_ptr);
  350.     test.n_ptr = xlarg(&clist.n_ptr);
  351.  
  352.     /* execute the loop as long as the test is false */
  353.     rbreak = FALSE;
  354.     while (xleval(test.n_ptr) == NIL) {
  355.  
  356.     /* execute the body of the loop */
  357.     if (tagblock(arg.n_ptr,&rval)) {
  358.         rbreak = TRUE;
  359.         break;
  360.     }
  361.  
  362.     /* update the looping variables */
  363.     doupdates(blist.n_ptr,pflag);
  364.     }
  365.  
  366.     /* evaluate the result expression */
  367.     if (!rbreak)
  368.     for (rval = NIL; consp(clist.n_ptr); )
  369.         rval = xlevarg(&clist.n_ptr);
  370.  
  371.     /* unbind the arguments */
  372.     xlunbind(oldenv); xlnewenv = oldnewenv;
  373.  
  374.     /* restore the previous stack frame */
  375.     xlstack = oldstk;
  376.  
  377.     /* return the result */
  378.     return (rval);
  379. }
  380.  
  381. /* xdolist - built-in function 'dolist' */
  382. NODE *xdolist(args)
  383.   NODE *args;
  384. {
  385.     NODE *oldstk,*oldenv,arg,clist,sym,list,val,*rval;
  386.     int rbreak;
  387.  
  388.     /* create a new stack frame */
  389.     oldstk = xlsave(&arg,&clist,&sym,&list,&val,NULL);
  390.  
  391.     /* initialize */
  392.     arg.n_ptr = args;
  393.  
  394.     /* get the control list (sym list result-expr) */
  395.     clist.n_ptr = xlmatch(LIST,&arg.n_ptr);
  396.     sym.n_ptr = xlmatch(SYM,&clist.n_ptr);
  397.     list.n_ptr = xlevmatch(LIST,&clist.n_ptr);
  398.     val.n_ptr = (clist.n_ptr ? xlarg(&clist.n_ptr) : NIL);
  399.  
  400.     /* initialize the local environment */
  401.     oldenv = xlenv;
  402.     xlsbind(sym.n_ptr,NIL);
  403.  
  404.     /* loop through the list */
  405.     rbreak = FALSE;
  406.     for (; consp(list.n_ptr); list.n_ptr = cdr(list.n_ptr)) {
  407.  
  408.     /* bind the symbol to the next list element */
  409.     sym.n_ptr->n_symvalue = car(list.n_ptr);
  410.  
  411.     /* execute the loop body */
  412.     if (tagblock(arg.n_ptr,&rval)) {
  413.         rbreak = TRUE;
  414.         break;
  415.     }
  416.     }
  417.  
  418.     /* evaluate the result expression */
  419.     if (!rbreak) {
  420.     sym.n_ptr->n_symvalue = NIL;
  421.     rval = xleval(val.n_ptr);
  422.     }
  423.  
  424.     /* unbind the arguments */
  425.     xlunbind(oldenv);
  426.  
  427.     /* restore the previous stack frame */
  428.     xlstack = oldstk;
  429.  
  430.     /* return the result */
  431.     return (rval);
  432. }
  433.  
  434. /* xdotimes - built-in function 'dotimes' */
  435. NODE *xdotimes(args)
  436.   NODE *args;
  437. {
  438.     NODE *oldstk,*oldenv,arg,clist,sym,val,*rval;
  439.     int rbreak,cnt,i;
  440.  
  441.     /* create a new stack frame */
  442.     oldstk = xlsave(&arg,&clist,&sym,&val,NULL);
  443.  
  444.     /* initialize */
  445.     arg.n_ptr = args;
  446.  
  447.     /* get the control list (sym list result-expr) */
  448.     clist.n_ptr = xlmatch(LIST,&arg.n_ptr);
  449.     sym.n_ptr = xlmatch(SYM,&clist.n_ptr);
  450.     cnt = xlevmatch(INT,&clist.n_ptr)->n_int;
  451.     val.n_ptr = (clist.n_ptr ? xlarg(&clist.n_ptr) : NIL);
  452.  
  453.     /* initialize the local environment */
  454.     oldenv = xlenv;
  455.     xlsbind(sym.n_ptr,NIL);
  456.  
  457.     /* loop through for each value from zero to cnt-1 */
  458.     rbreak = FALSE;
  459.     for (i = 0; i < cnt; i++) {
  460.  
  461.     /* bind the symbol to the next list element */
  462.     sym.n_ptr->n_symvalue = newnode(INT);
  463.     sym.n_ptr->n_symvalue->n_int = i;
  464.  
  465.     /* execute the loop body */
  466.     if (tagblock(arg.n_ptr,&rval)) {
  467.         rbreak = TRUE;
  468.         break;
  469.     }
  470.     }
  471.  
  472.     /* evaluate the result expression */
  473.     if (!rbreak) {
  474.     sym.n_ptr->n_symvalue = newnode(INT);
  475.     sym.n_ptr->n_symvalue->n_int = cnt;
  476.     rval = xleval(val.n_ptr);
  477.     }
  478.  
  479.     /* unbind the arguments */
  480.     xlunbind(oldenv);
  481.  
  482.     /* restore the previous stack frame */
  483.     xlstack = oldstk;
  484.  
  485.     /* return the result */
  486.     return (rval);
  487. }
  488.  
  489. /* xcatch - built-in function 'catch' */
  490. NODE *xcatch(args)
  491.   NODE *args;
  492. {
  493.     NODE *oldstk,tag,arg,*val;
  494.     CONTEXT cntxt;
  495.  
  496.     /* create a new stack frame */
  497.     oldstk = xlsave(&tag,&arg,NULL);
  498.  
  499.     /* initialize */
  500.     tag.n_ptr = xlevarg(&args);
  501.     arg.n_ptr = args;
  502.     val = NIL;
  503.  
  504.     /* establish an execution context */
  505.     xlbegin(&cntxt,CF_THROW,tag.n_ptr);
  506.  
  507.     /* check for 'throw' */
  508.     if (setjmp(cntxt.c_jmpbuf))
  509.     val = xlvalue;
  510.  
  511.     /* otherwise, evaluate the remainder of the arguments */
  512.     else {
  513.     while (arg.n_ptr)
  514.         val = xlevarg(&arg.n_ptr);
  515.     }
  516.     xlend(&cntxt);
  517.  
  518.     /* restore the previous stack frame */
  519.     xlstack = oldstk;
  520.  
  521.     /* return the result */
  522.     return (val);
  523. }
  524.  
  525. /* xthrow - built-in function 'throw' */
  526. NODE *xthrow(args)
  527.   NODE *args;
  528. {
  529.     NODE *tag,*val;
  530.  
  531.     /* get the tag and value */
  532.     tag = xlarg(&args);
  533.     val = (args ? xlarg(&args) : NIL);
  534.     xllastarg(args);
  535.  
  536.     /* throw the tag */
  537.     xlthrow(tag,val);
  538. }
  539.  
  540. /* xerror - built-in function 'error' */
  541. NODE *xerror(args)
  542.   NODE *args;
  543. {
  544.     char *emsg; NODE *arg;
  545.  
  546.     /* get the error message and the argument */
  547.     emsg = xlmatch(STR,&args)->n_str;
  548.     arg = (args ? xlarg(&args) : s_unbound);
  549.     xllastarg(args);
  550.  
  551.     /* signal the error */
  552.     xlerror(emsg,arg);
  553. }
  554.  
  555. /* xcerror - built-in function 'cerror' */
  556. NODE *xcerror(args)
  557.   NODE *args;
  558. {
  559.     char *cmsg,*emsg; NODE *arg;
  560.  
  561.     /* get the correction message, the error message, and the argument */
  562.     cmsg = xlmatch(STR,&args)->n_str;
  563.     emsg = xlmatch(STR,&args)->n_str;
  564.     arg = (args ? xlarg(&args) : s_unbound);
  565.     xllastarg(args);
  566.  
  567.     /* signal the error */
  568.     xlcerror(cmsg,emsg,arg);
  569.  
  570.     /* return nil */
  571.     return (NIL);
  572. }
  573.  
  574. /* xbreak - built-in function 'break' */
  575. NODE *xbreak(args)
  576.   NODE *args;
  577. {
  578.     char *emsg; NODE *arg;
  579.  
  580.     /* get the error message */
  581.     emsg = (args ? xlmatch(STR,&args)->n_str : "**BREAK**");
  582.     arg = (args ? xlarg(&args) : s_unbound);
  583.     xllastarg(args);
  584.  
  585.     /* enter the break loop */
  586.     xlbreak(emsg,arg);
  587.  
  588.     /* return nil */
  589.     return (NIL);
  590. }
  591.  
  592. /* xerrset - built-in function 'errset' */
  593. NODE *xerrset(args)
  594.   NODE *args;
  595. {
  596.     NODE *oldstk,expr,flag,*val;
  597.     CONTEXT cntxt;
  598.  
  599.     /* create a new stack frame */
  600.     oldstk = xlsave(&expr,&flag,NULL);
  601.  
  602.     /* get the expression and the print flag */
  603.     expr.n_ptr = xlarg(&args);
  604.     flag.n_ptr = (args ? xlarg(&args) : true);
  605.     xllastarg(args);
  606.  
  607.     /* establish an execution context */
  608.     xlbegin(&cntxt,CF_ERROR,flag.n_ptr);
  609.  
  610.     /* check for error */
  611.     if (setjmp(cntxt.c_jmpbuf))
  612.     val = NIL;
  613.  
  614.     /* otherwise, evaluate the expression */
  615.     else {
  616.     expr.n_ptr = xleval(expr.n_ptr);
  617.     val = newnode(LIST);
  618.     rplaca(val,expr.n_ptr);
  619.     }
  620.     xlend(&cntxt);
  621.  
  622.     /* restore the previous stack frame */
  623.     xlstack = oldstk;
  624.  
  625.     /* return the result */
  626.     return (val);
  627. }
  628.  
  629. /* xevalhook - eval hook function */
  630. NODE *xevalhook(args)
  631.   NODE *args;
  632. {
  633.     NODE *oldstk,*oldenv,expr,ehook,ahook,*val;
  634.  
  635.     /* create a new stack frame */
  636.     oldstk = xlsave(&expr,&ehook,&ahook,NULL);
  637.  
  638.     /* get the expression and the hook functions */
  639.     expr.n_ptr = xlarg(&args);
  640.     ehook.n_ptr = xlarg(&args);
  641.     ahook.n_ptr = xlarg(&args);
  642.     xllastarg(args);
  643.  
  644.     /* bind *evalhook* and *applyhook* to the hook functions */
  645.     oldenv = xlenv;
  646.     xlsbind(s_evalhook,ehook.n_ptr);
  647.     xlsbind(s_applyhook,ahook.n_ptr);
  648.  
  649.     /* evaluate the expression (bypassing *evalhook*) */
  650.     val = xlxeval(expr.n_ptr);
  651.  
  652.     /* unbind the hook variables */
  653.     xlunbind(oldenv);
  654.  
  655.     /* restore the previous stack frame */
  656.     xlstack = oldstk;
  657.  
  658.     /* return the result */
  659.     return (val);
  660. }
  661.  
  662. /* dobindings - handle bindings for let/let*, prog/prog*, do/do* */
  663. LOCAL dobindings(blist,pflag)
  664.   NODE *blist; int pflag;
  665. {
  666.     NODE *oldstk,list,bnd,sym,val;
  667.  
  668.     /* create a new stack frame */
  669.     oldstk = xlsave(&list,&bnd,&sym,&val,NULL);
  670.  
  671.    /* bind each symbol in the list of bindings */
  672.     for (list.n_ptr = blist; consp(list.n_ptr); list.n_ptr = cdr(list.n_ptr)) {
  673.  
  674.     /* get the next binding */
  675.     bnd.n_ptr = car(list.n_ptr);
  676.  
  677.     /* handle a symbol */
  678.     if (symbolp(bnd.n_ptr)) {
  679.         sym.n_ptr = bnd.n_ptr;
  680.         val.n_ptr = NIL;
  681.     }
  682.  
  683.     /* handle a list of the form (symbol expr) */
  684.     else if (consp(bnd.n_ptr)) {
  685.         sym.n_ptr = xlmatch(SYM,&bnd.n_ptr);
  686.         val.n_ptr = xlevarg(&bnd.n_ptr);
  687.     }
  688.     else
  689.         xlfail("bad binding");
  690.  
  691.     /* bind the value to the symbol */
  692.     if (pflag)
  693.         xlbind(sym.n_ptr,val.n_ptr);
  694.     else
  695.         xlsbind(sym.n_ptr,val.n_ptr);
  696.     }
  697.  
  698.     /* fix the bindings on a parallel let */
  699.     if (pflag)
  700.     xlfixbindings();
  701.  
  702.     /* restore the previous stack frame */
  703.     xlstack = oldstk;
  704. }
  705.  
  706. /* doupdates - handle updates for do/do* */
  707. doupdates(blist,pflag)
  708.   NODE *blist; int pflag;
  709. {
  710.     NODE *oldstk,*oldenv,*oldnewenv,list,bnd,sym,val;
  711.  
  712.     /* create a new stack frame */
  713.     oldstk = xlsave(&list,&bnd,&sym,&val,NULL);
  714.  
  715.     /* initialize the local environment */
  716.     if (pflag) {
  717.     oldenv = xlenv; oldnewenv = xlnewenv;
  718.     }
  719.  
  720.     /* bind each symbol in the list of bindings */
  721.     for (list.n_ptr = blist; consp(list.n_ptr); list.n_ptr = cdr(list.n_ptr)) {
  722.  
  723.     /* get the next binding */
  724.     bnd.n_ptr = car(list.n_ptr);
  725.  
  726.     /* handle a list of the form (symbol expr) */
  727.     if (consp(bnd.n_ptr)) {
  728.         sym.n_ptr = xlmatch(SYM,&bnd.n_ptr);
  729.         bnd.n_ptr = cdr(bnd.n_ptr);
  730.         if (bnd.n_ptr) {
  731.         val.n_ptr = xlevarg(&bnd.n_ptr);
  732.         if (pflag)
  733.             xlbind(sym.n_ptr,val.n_ptr);
  734.         else
  735.             sym.n_ptr->n_symvalue = val.n_ptr;
  736.         }
  737.     }
  738.     }
  739.  
  740.     /* fix the bindings on a parallel let */
  741.     if (pflag) {
  742.     xlfixbindings();
  743.     xlenv = oldenv; xlnewenv = oldnewenv;
  744.     }
  745.  
  746.     /* restore the previous stack frame */
  747.     xlstack = oldstk;
  748. }
  749.  
  750. /* tagblock - execute code within a block and tagbody */
  751. int tagblock(code,pval)
  752.   NODE *code,**pval;
  753. {
  754.     NODE *oldstk,arg;
  755.     CONTEXT cntxt;
  756.     int type,sts;
  757.  
  758.     /* create a new stack frame */
  759.     oldstk = xlsave(&arg,NULL);
  760.  
  761.     /* initialize */
  762.     arg.n_ptr = code;
  763.  
  764.     /* establish an execution context */
  765.     xlbegin(&cntxt,CF_GO|CF_RETURN,arg.n_ptr);
  766.  
  767.     /* check for a 'return' */
  768.     if ((type = setjmp(cntxt.c_jmpbuf)) == CF_RETURN) {
  769.     *pval = xlvalue;
  770.     sts = TRUE;
  771.     }
  772.  
  773.     /* otherwise, enter the body */
  774.     else {
  775.  
  776.     /* check for a 'go' */
  777.     if (type == CF_GO)
  778.         arg.n_ptr = xlvalue;
  779.  
  780.     /* evaluate each expression in the body */
  781.     while (consp(arg.n_ptr))
  782.         if (consp(car(arg.n_ptr)))
  783.         xlevarg(&arg.n_ptr);
  784.         else
  785.         arg.n_ptr = cdr(arg.n_ptr);
  786.     
  787.     /* indicate that we fell through the bottom of the tagbody */
  788.     *pval = NIL;
  789.     sts = FALSE;
  790.     }
  791.     xlend(&cntxt);
  792.  
  793.     /* restore the previous stack frame */
  794.     xlstack = oldstk;
  795.  
  796.     /* return status */
  797.     return (sts);
  798. }
  799.